home *** CD-ROM | disk | FTP | other *** search
/ Aminet 4 / Aminet 4 - November 1994.iso / aminet / dev / obero / oberon_lib.lha / oberon-a / source1.lha / source / ProjectOberon / Oberon.mod < prev    next >
Text File  |  1994-08-08  |  3KB  |  135 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: Oberon.mod $
  4.   Description: Partial port of the Project Oberon module
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 1.5 $
  8.       $Author: fjc $
  9.         $Date: 1994/08/08 16:40:46 $
  10.  
  11.   Copyright © 1994, Frank Copeland.
  12.   This file is part of the Oberon-A Library.
  13.   See Oberon-A.doc for conditions of use and distribution.
  14.  
  15.   Log entries are at the end of the file.
  16.  
  17. ***************************************************************************)
  18.  
  19. MODULE Oberon;
  20.  
  21. (*
  22. ** $C= CaseChk       $I= IndexChk  $L+ LongAdr   $N= NilChk
  23. ** $P= PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
  24. ** $V= OvflChk       $Z= ZeroVars
  25. *)
  26.  
  27. IMPORT Dos;
  28.  
  29. (*------------------------------------*)
  30. PROCEDURE ADOS2OberonTime *
  31.   (VAR ds : Dos.Date; VAR time, date : LONGINT);
  32. (*
  33.   Adapted from ParseDate() in module Dates, Copyright 1987 by:
  34.     Dale W. Thompson, 14500 Dallas Pkwy. #2091, Dallas, TX 75240
  35. *)
  36.  
  37.   VAR year, month, day, hour, min, sec : LONGINT;
  38.       Days     : ARRAY 12 OF INTEGER;
  39.       LeapDays : ARRAY 12 OF INTEGER;
  40.  
  41.    PROCEDURE Leap ( year : LONGINT ) : BOOLEAN;
  42.    BEGIN
  43.       RETURN ((year-1976) MOD 4) = 0
  44.    END Leap;
  45.  
  46. BEGIN (* ADOS2OberonTime *)
  47.   hour := ds.minute DIV 60;
  48.   min := ds.minute MOD 60;
  49.   sec := ds.tick DIV Dos.ticksPerSecond;
  50.  
  51.   Days[0]  := 31;  LeapDays[0]  := 31;
  52.   Days[1]  := 28;  LeapDays[1]  := 29;
  53.   Days[2]  := 31;  LeapDays[2]  := 31;
  54.   Days[3]  := 30;  LeapDays[3]  := 30;
  55.   Days[4]  := 31;  LeapDays[4]  := 31;
  56.   Days[5]  := 30;  LeapDays[5]  := 30;
  57.   Days[6]  := 31;  LeapDays[6]  := 31;
  58.   Days[7]  := 31;  LeapDays[7]  := 31;
  59.   Days[8]  := 30;  LeapDays[8]  := 30;
  60.   Days[9]  := 31;  LeapDays[9]  := 31;
  61.   Days[10] := 30;  LeapDays[10] := 30;
  62.   Days[11] := 31;  LeapDays[11] := 31;
  63.  
  64.   day := ds.days;
  65.   year := 1978;
  66.   LOOP
  67.     IF Leap (year) THEN
  68.       IF day < 366 THEN
  69.          EXIT;
  70.       ELSE
  71.          DEC( day,366 );
  72.       END;
  73.     ELSE
  74.       IF day < 365 THEN
  75.          EXIT;
  76.       ELSE
  77.          DEC( day,365 );
  78.       END;
  79.     END;
  80.     INC (year);
  81.   END; (* LOOP *)
  82.   INC (day);
  83.  
  84.   month := 0;
  85.   IF Leap (year) THEN
  86.     WHILE day > LeapDays [month] DO
  87.       DEC (day, LeapDays [month]);
  88.       INC (month);
  89.     END;
  90.   ELSE
  91.     WHILE day > Days [month] DO
  92.       DEC (day, Days [month]);
  93.       INC (month);
  94.     END;
  95.   END;
  96.   INC (month);
  97.  
  98.   time := (hour * 64 + min) * 64 + sec;
  99.   date := (year * 16 + month) * 32 + day;
  100. END ADOS2OberonTime;
  101.  
  102. (*------------------------------------*)
  103. PROCEDURE GetClock * (VAR time, date : LONGINT);
  104.  
  105.   VAR ds : Dos.Date;
  106.  
  107. BEGIN (* GetClock *)
  108.   Dos.base.DateStamp (ds);
  109.   ADOS2OberonTime (ds, time, date);
  110. END GetClock;
  111.  
  112.  
  113. END Oberon.
  114.  
  115. (***************************************************************************
  116.  
  117.   $Log: Oberon.mod $
  118.   Revision 1.5  1994/08/08  16:40:46  fjc
  119.   Release 1.4
  120.  
  121.   Revision 1.4  1994/06/14  02:14:31  fjc
  122.   - Updated for release
  123.  
  124.   Revision 1.3  1994/06/04  16:03:39  fjc
  125.   - Changed to use new Amiga interface
  126.  
  127.   Revision 1.2  1994/05/12  20:45:18  fjc
  128.   - Prepared for release
  129.  
  130. # Revision 1.1  1994/01/15  21:39:12  fjc
  131. # Start of revision control
  132. #
  133. ***************************************************************************)
  134.  
  135.